home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / macros.t < prev    next >
Text File  |  1988-05-02  |  17KB  |  455 lines
  1. (herald macros (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; Standard macros
  27.  
  28. (define-safe-syntax (define . x)
  29.                     (| (symbol? #f)
  30.                        ((symbol? . formals-list?) . (+ #f)))
  31.   (cond ((pair? (car x))
  32.          `(,(t-syntax 'define-variable-value) ,(caar x)
  33.             (,(t-syntax 'named-lambda) ,(caar x) ,(cdar x) . ,(cdr x))))
  34.         ((null? (cddr x))
  35.          `(,(t-syntax 'define-variable-value) ,(car x) ,(cadr x)))
  36.         (else
  37.          (syntax-error "illegal definition syntax~%  ~S" `(define . ,x)))))
  38.  
  39. (define-syntax (define-integrable . x)
  40.   `(,(t-syntax 'define-constant) . ,x))
  41.  
  42. (define-safe-syntax (define-constant . x)
  43.                     (| (symbol? #f)
  44.                        ((symbol? . formals-list?) . (+ #f)))
  45.   (receive (ok? var val)
  46.            (cond ((pair? (car x))
  47.                   (return t
  48.                           (caar x)
  49.                           `(,(t-syntax 'named-lambda) ,(caar x) ,(cdar x) . ,(cdr x))))
  50.                  ((null? (cddr x))
  51.                   (return t (car x) (cadr x)))
  52.                  (else
  53.                   (return nil nil nil)))
  54.     (if (not ok?)
  55.         (syntax-error "illegal definition syntax~%  ~S" `(define-constant . ,x))
  56.         `(,(t-syntax 'block)
  57.           (,(t-syntax 'declare) constant ,var)
  58.           (,(t-syntax 'define-variable-value) ,var ,val)))))
  59.  
  60. (define-syntax (define-recursive . x)
  61.   (cond ((pair? (car x))
  62.          `(,(t-syntax 'define-variable-value) ,(caar x)
  63.             (,(t-syntax 'named-lambda) ,(caar x) ,(cdar x)
  64.               (labels ((,(car x)  ,@(cdr x)))
  65.                 ,(car x)))))
  66.         ((null? (cddr x))
  67.          ;++ this should probably be an error
  68.          `(,(t-syntax 'define-variable-value) ,(car x)
  69.             (labels ((,(car x) ,(cadr x)))
  70.                 ,(car x))))
  71.         (else
  72.          (syntax-error "illegal definition syntax~%  ~S"
  73.                        `(define-recursive . ,x)))))
  74.  
  75. ;;; We use BLOCK here to keep the LSET-VARIABLE-VALUE at top level.
  76. ;;; Returning PLACE is done for compatibility with T2.
  77.  
  78. (define-syntax (lset place value)
  79.   `(,(t-syntax 'block)
  80.      (,(t-syntax 'lset-variable-value) ,place ,value)
  81.        ,place))
  82.  
  83.  
  84. (define-syntax (define-handler name . body)
  85.   (let ((type    (concatenate-symbol 'header/ name))
  86.         (handler (concatenate-symbol 'handle- name)))
  87.   `(block
  88.     (define ,handler ,@body)
  89.     (set (vref *handlers* (fx-ashr ,type 2)) ,handler)
  90.     (no-value))))
  91.  
  92. (define-syntax (set place value)
  93.   (let ((var (generate-symbol 'set)))
  94.     `(let ((,var ,value))
  95.        ,(cond ((atom? place)
  96.                `(,(t-syntax 'set-variable-value) ,place ,var))
  97.               (else
  98.                `((setter ,(car place)) ,@(cdr place) ,var)))
  99.        ,var)))
  100.  
  101. (define-syntax (locative form)
  102.   (cond ((atom? form)
  103.      `(,(t-syntax 'var-locative) ,form))
  104.     (else
  105.      `(make-locative ,@form))))     ; ??
  106.  
  107. (define-syntax (delay x)
  108.   `(make-delay (,(t-syntax 'lambda) () ,x)))
  109.  
  110. (define (blockify x)
  111.   (cond ((atom? x) ''#f)
  112.         ((atom? (cdr x)) (car x))
  113.         (else `(,(t-syntax 'block) ,@x))))
  114.  
  115. (define-safe-syntax (block0 val . body)
  116.                     (+ #f)
  117.   (let ((g (generate-symbol 'block0)))
  118.     `((,(t-syntax 'lambda) (,g) ,@body ,g) ,val)))
  119.  
  120. (define-safe-syntax (define-structure-type type-id . specs)
  121.                     (symbol? (@ symbol?) . (| null? ((* valid-method-form?))))
  122.   (let ((stype (concatenate-symbol type-id '-stype)))
  123.     (receive (handler specs)
  124.              (let* ((last (last specs))
  125.                     (h (cond ((not (pair? last)) '())
  126.                              (else last))))
  127.                (return `(object nil
  128.                           ,@h
  129.                           ((crawl-exhibit self)
  130.                            (exhibit-structure self))
  131.                           ((print self port)
  132.                            (print-structure self port)) ;??
  133.                           ((structure-type self) ,stype))
  134.                        (if (pair? last)
  135.                            (delq last specs)
  136.                            specs)))
  137.       `(block (define ,stype (make-stype ',type-id ',specs '#f))
  138.               (set (stype-handler ,stype) ,handler)
  139.               (define ,(concatenate-symbol 'make- type-id)
  140.                 (stype-constructor ,stype))
  141.               (define ,(concatenate-symbol type-id '?)
  142.                 (stype-predicator ,stype))
  143.               ,@(do ((s specs (cdr s))
  144.                      (i 2 (fx+ i 4))
  145.                      (z '()
  146.                         (cons `(define-constant
  147.                                 ,(concatenate-symbol type-id '- (car s))
  148.                                 (make-structure-accessor ,stype ,i ',(car s)))
  149.                               z)))
  150.                   ((null? s) (reverse! z)))
  151.               ,stype))))
  152.  
  153.  
  154. ;;; iteration constructs
  155.  
  156. (comment
  157. (define-syntax (label clause-1 . rest)
  158.   (let ((form-iterate (lambda (name varinits body)
  159.                         `(,(t-syntax 'labels)
  160.                               ((,name (,(t-syntax 'lambda) ,(map car varinits)
  161.                                         . ,body)))
  162.                            (,name . ,(map cadr varinits))))))
  163.     (if (symbol? clause-1)
  164.         (form-iterate clause-1 (car rest) (cdr rest))
  165.       (form-iterate (car clause-1) (cdr clause-1) rest))))
  166. )
  167.  
  168. ;;; Pattern doesn't allow for (ITERATE (FOO (X 1) ...) ...)
  169.  
  170. (define-safe-syntax (iterate clause-1 . rest)
  171.                     (symbol? (* (symbol? #f)) . (+ #f))
  172.   (let ((form-iterate (lambda (name varinits body)
  173.                         `(,(t-syntax 'labels)
  174.                               ((,name (,(t-syntax 'lambda) ,(map car varinits)
  175.                                         . ,body)))
  176.                            (,name . ,(map cadr varinits))))))
  177.     (if (symbol? clause-1)
  178.         (form-iterate clause-1 (car rest) (cdr rest))
  179.       (form-iterate (car clause-1) (cdr clause-1) rest))))
  180.  
  181.  
  182. ;;; expand into explicit lambda's in the rhs's of labelses, so as to
  183. ;;; increase the information content of backtrace output.  (otherwise the
  184. ;;; local procedures handle identification, and you get lots of loop's and
  185. ;;; do.137's in the backtrace.)
  186.  
  187. (define-safe-syntax (do specs end . body)
  188.                     ((* (| (symbol? #f #f) (symbol? #f) (symbol?)))
  189.                      (+ #f)
  190.                      . (* #f))
  191.   (let ((loop (generate-symbol 'do)))
  192.     `(,(t-syntax 'labels)
  193.        ((,loop (,(t-syntax 'lambda) ,(map car specs)
  194.                  (,(t-syntax 'cond) ,end
  195.                    (else ,(blockify
  196.                            `(,@body
  197.                              (,loop
  198.                               ,@(map (lambda (y)
  199.                                        (if (and (cdr y) (cddr y))
  200.                                            (caddr y)
  201.                                            (car y)))
  202.                                      specs)))))))))
  203.        (,loop ,@(map (lambda (y) (if (cdr y) (cadr y) ''#f)) specs)))))
  204.                 
  205. ;;; (unwind-protect body . unwind-forms)
  206.  
  207. (define-safe-syntax (unwind-protect body . unwind-forms)
  208.                     ((* #f) . (+ #f))
  209.   `(unwind-protect-handler (,(t-syntax 'lambda) () ,body)
  210.                            (,(t-syntax 'lambda) () . ,unwind-forms)))
  211.  
  212. ;;; (with-output-to-string var . body) binds VAR to an output port
  213. ;;; and executes the body.  Anything written to the output port
  214. ;;; during the execution of body is accumulated in a string, which
  215. ;;; is returned as the value of the with-output-to-string-expression.
  216.  
  217. ;(define-safe-syntax (with-output-to-string pat . body)
  218. ;                    (symbol? . (+ #f))
  219. ;  (let ((var (if (pair? pat) (car pat) pat)))
  220. ;    `(let ((,var (make-output-to-string-stream)))
  221. ;       ,@body
  222. ;       (close ,var))))
  223.  
  224. (define-safe-syntax (with-output-to-string pat . body)
  225.                     (symbol? . (+ #f))
  226.   (let ((var (if (pair? pat) (car pat) pat)))
  227.     `(,(t-syntax 'let) ((,var (get-buffer)))
  228.        ,@body
  229.        (let ((val (buffer->string ,var)))
  230.          (release-buffer ,var)
  231.          val))))
  232.  
  233. (define-safe-syntax (with-input-from-string pat . body)
  234.                     ((symbol? #f) . (+ #f))
  235.   (let ((var (car pat))
  236.         (string (cadr pat)))
  237.     `(,(t-syntax 'let) ((,var (string->input-port ,string)))
  238.        (,(t-syntax 'block0) ,(blockify body)
  239.                             (close ,var)))))
  240.  
  241. ;++ This isn't used or released should we flush it.
  242. ;;; (with-output-to-list var . body) is like (string->list
  243. ;;; (with-output-to-string var . body)).  It could be implemented
  244. ;;; more efficiently but i'm too lazy to do so.
  245.  
  246. (define-syntax (with-output-to-list var . body)
  247.   `(string->list (with-output-to-string ,var . ,body)))
  248.  
  249. ;;; (WITH-OUTPUT-WIDTH-port VAR . BODY) is like
  250. ;;; WITH-OUTPUT-TO-STRING, but instead of accumulating characters
  251. ;;; in a string, it counts them.  the value returned is the number
  252. ;;; of characters counted.  For an example see the definition
  253. ;;; of printwidth.
  254.  
  255. (define-syntax (with-output-width-port var . body)
  256.   `(let ((,var (make-output-width-port)))
  257.      ,@body
  258.      (close ,var)))
  259.  
  260. ;;; with-open-ports
  261.  
  262. (define-safe-syntax (with-open-ports specs . body)
  263.                     ((* (symbol? #f)) . (+ #f))
  264.   `(with-open-ports-handler
  265.     (,(t-syntax 'lambda) ,(map car specs)
  266.       . ,body)
  267.     ,@(map (lambda (spec)
  268.              `(,(t-syntax 'lambda) () ,(cadr spec)))
  269.            specs)))
  270.  
  271. ;;; random
  272.  
  273. (define-syntax (import env . vars)
  274.   (let ((g (generate-symbol 'import)))
  275.     `(,(t-syntax 'let) ((,g ,env))
  276.        ,@(map (lambda (var)
  277.                 (let ((var (enforce symbol? var )))
  278.                   `(,(t-syntax 'define) ,var (*value ,g ',var))))
  279.               vars))))
  280.  
  281. ;(define-syntax (export env . vars)
  282. ;  (let ((g (generate-symbol 'export)))
  283. ;    `(let ((g ,env))
  284. ;       ,@(map (lambda (var) `(*define ,g ',var ,var))
  285. ;              vars))))
  286.  
  287. (define-syntax (require name . maybe-path)
  288.   (cond (maybe-path
  289.          `(*require ',name ',(car maybe-path) (,(t-syntax 'the-environment))))
  290.         (else
  291.          `(*require '() ',name (,(t-syntax 'the-environment))))))
  292.  
  293. (define-syntax (catch var . body)
  294.   `(*catch (,(t-syntax 'lambda) (,var) . ,body)))
  295.  
  296. (define-syntax (comment . rest)
  297.   (ignore rest)
  298.   ''comment)                            ; a tradition of sorts.
  299.  
  300. (define-syntax (ignore . vars)
  301.   `(,(t-syntax 'declare) ignore . ,vars))
  302.  
  303. (define-syntax (ignorable . vars)
  304.   `(,(t-syntax 'declare) ignorable . ,vars))
  305.  
  306. (define-syntax (herald . rest)
  307.   (syntax-error "herald form in illegal context~%  ~s"
  308.                 `(herald . ,rest)))
  309.  
  310. ;;; This is used for critical sections, usually for heap integrety
  311. ;;; or other GC related reason.
  312.  
  313. (define-syntax (defer-interrupts . body) 
  314.   `(,(t-syntax 'block) ,@body))
  315.  
  316. ;(define-syntax (defer-interrupts . body) 
  317. ;  `(block (disable-interrupts)
  318. ;          (let ((val (block ,@body)))
  319. ;            (enable-interrupts)
  320. ;            val)))
  321.  
  322. ;;; Free list versions of POP and PUSH
  323.  
  324. (define-syntax (free-push form thing)
  325.   (let ((fetch (generate-symbol 'fetch))
  326.         (store (generate-symbol 'store)))
  327.     `(,(t-syntax 'modify-location) , form
  328.        (,(t-syntax 'lambda) (,fetch ,store)
  329.          (,store (cons-from-freelist ,thing (,fetch)))))))
  330.  
  331. (define-syntax (free-pop form)
  332.   `(,(t-syntax 'modify-location) ,form
  333.      (,(t-syntax 'lambda) (fetch store)
  334.        (,(t-syntax 'let*) ((temp (fetch)) (v (car temp)))
  335.          (store (cdr temp))
  336.          (return-to-freelist temp)
  337.          v))))
  338.  
  339.  
  340. ;*** (WITH-BUFFERS specs . BODY)
  341. ;*** =======================================================================
  342. ;*** This macro is used to allocate and release one or more buffers.
  343. ;*** Specs is a list of (name size) pairs.  If size is omitted then
  344. ;*** the minimum buffer size (64 bytes) is used.  With-buffers forces
  345. ;*** the release of the named buffers on a throw past the binders.
  346. ;***
  347.  
  348. (define-safe-syntax (with-buffers specs . body)
  349.                     ((* (symbol? . (| null? (#f)))) . (+ #f))
  350.   (cond ((every? valid-spec? specs)
  351.          `(let (,@(map (lambda (spec)
  352.                          (cond ((atom? (cdr spec))
  353.                                 `(,(car spec) (get-buffer)))
  354.                                (else
  355.                                 `(,(car spec) (get-buffer-of-size
  356.                                                ,(cadr spec))))))
  357.                        specs))
  358.             (receive vals (block ,@body)
  359.               ,@(map (lambda (spec)
  360.                        `(release-buffer ,(car spec)))
  361.                      specs)
  362.                (apply return vals))))    
  363.         (else
  364.          (syntax-error "illegal spec~%  ~S"
  365.                       `(with-buffer ,specs . ,body)))))
  366.  
  367.  
  368. ;;; Define a simple switch.
  369.  
  370. (define-syntax (define-simple-switch name type . initial-value)
  371.   `(define ,name (make-simple-switch ',name ,type ,@initial-value)))
  372.  
  373. ;;; Useful for defining unimplemented procedures
  374.  
  375. (define-syntax (define-unimplemented pat . msg)
  376.   (destructure (((name . args) pat))
  377.     (let ((fmt (if msg
  378.                    "~a is unimplemented~%**~11t~a"
  379.                    "~a is unimplemented")))
  380.       `(define (,name ,@args)
  381.          (error ,fmt (identification ,name) ,@msg)))))
  382.  
  383. ;;; Assert - (assert (fixnum? x) (float? y) (structure? z))
  384.  
  385. (define-syntax (assert . types)
  386.   `(block
  387.     (,(t-syntax 'declare) assert ,@types)
  388.     (no-value)))
  389.  
  390. ;;; syntax-related stuff
  391.  
  392. (define-safe-syntax (safe-macro-expander pat pattern . rest)
  393.                     ((symbol? . formals-list?) #f . (+ #f))
  394.   (let* ((pat (enforce pair? pat ))
  395.          (symbol (car pat))
  396.          (args   (cdr pat))
  397.          (z (generate-symbol 'macro)))
  398.     `(make-macro-descriptor (,(t-syntax 'named-lambda) ,symbol (,z)
  399.                               (,(t-syntax 'ignorable) ,z)
  400.                               ;; careful!  look at disclose-macro-expander.
  401.                               (,(t-syntax 'destructure) (((#f . ,args) ,z))
  402.                                 . ,rest))
  403.                             (,(t-syntax 'pattern-predicate) ,pattern)
  404.                             ',symbol)))
  405.  
  406. (define-safe-syntax (define-safe-syntax pat pattern . rest)
  407.                     (| (symbol? #f #f)
  408.                        ((symbol? . formals-list?) #f . (+ #f)))
  409.   (let ((construct
  410.          (lambda (symbol descr)
  411.            (let ((symbol (enforce symbol? symbol)))
  412.              `(*define-syntax (,(t-syntax 'the-environment))
  413.                               ',symbol
  414.                               ,descr)))))
  415.     (cond ((pair? pat)
  416.            (construct (car pat)
  417.                       `(,(t-syntax 'safe-macro-expander)
  418.                         ,pat ,pattern . ,rest)))
  419.           (else
  420.            (construct pat (car rest))))))
  421.  
  422. ;;; Unsafe versions of the above
  423.  
  424. (define-safe-syntax (macro-expander pat . rest)
  425.                     ((symbol? . formals-list?) . (+ #f))
  426.   (let ((pattern 
  427.          (if (null? (cdr pat))
  428.              'null?
  429.              (iterate loop ((l (cdr pat)) (pat '()))
  430.                (cond ((null? l) pat)
  431.                      ((atom? l) (append! pat 'true))
  432.                      (else
  433.                      (loop (cdr l) (cons '#f pat))))))))
  434.     `(,(t-syntax 'safe-macro-expander) ,pat
  435.                                        ,pattern
  436.                                        . ,rest)))
  437.  
  438. (define-safe-syntax (define-syntax pat . rest)
  439.                     (| (symbol? #f)
  440.                        ((symbol? . formals-list?) . (+ #f)))
  441.   (let ((construct
  442.          (lambda (symbol descr)
  443.            (let ((symbol (enforce symbol? symbol)))
  444.              `(*define-syntax (,(t-syntax 'the-environment))
  445.                               ',symbol
  446.                               ,descr)))))
  447.     (cond ((pair? pat)
  448.            (construct (car pat)
  449.                       `(,(t-syntax 'macro-expander) ,pat . ,rest)))
  450.           (else
  451.            (cond ((not (null? (cdr rest)))
  452.                   (syntax-error "too many subforms~%  ~s"
  453.                                 `(define-syntax ,pat . ,rest))))
  454.            (construct pat (car rest))))))
  455.